home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / inspect-main.stk < prev    next >
Encoding:
Text File  |  1995-07-19  |  7.1 KB  |  191 lines
  1. ;******************************************************************************
  2. ;
  3. ; Project       : STk-inspect, a graphical debugger for STk
  4. ;
  5. ; File name     : inspect-main.stk
  6. ; Creation date : Aug-10-1993
  7. ; Last update   : Sep-17-1993
  8. ;
  9. ;******************************************************************************
  10. ;
  11. ; This file implements the "General inspector".
  12. ;
  13. ;******************************************************************************
  14.  
  15. (provide "inspect-main")
  16. (require "inspect-misc")
  17. (require "inspect-view")
  18. (require "inspect-detail")
  19. (require "inspect-help")
  20.  
  21. (define INSPECTOR_WIDGET_NAME      ".inspector")
  22. (define inspected-objects-list   ())
  23.  
  24. (define (inspected? obj) (member obj inspected-objects-list))
  25.  
  26. (define (inspect-frame-wid obj)
  27.   (widget INSPECTOR_WIDGET_NAME ".f1." (object-symbol obj)))
  28. (define (inspect-frame-str obj)
  29.   (& INSPECTOR_WIDGET_NAME ".f1." (object-symbol obj)))
  30.  
  31. (define (inspect-l-wid obj) (widget (inspect-frame-str obj) ".l"))
  32. (define (inspect-l-str obj) (& (inspect-frame-str obj) ".l"))
  33. (define (inspect-e-wid obj) (widget (inspect-frame-str obj) ".e"))
  34. (define (inspect-e-str obj) (& (inspect-frame-str obj) ".e"))
  35. (define (inspect-mb-wid obj) (widget (inspect-frame-str obj) ".mb"))
  36. (define (inspect-mb-str obj) (& (inspect-frame-str obj) ".mb"))
  37. (define (inspect-m-str obj) (& (inspect-frame-str obj) ".mb.m"))
  38. (define (inspect-m-wid obj) (widget (inspect-frame-str obj) ".mb.m"))
  39.  
  40.  
  41. ;---- Inspector menu
  42.  
  43. (define (create-inspect-menu obj)
  44.   (define w (eval [menu (inspect-m-str obj)]))
  45.   (w 'add 'command :label "Uninspect" 
  46.                 :command `(inspect-menu-Uninspect ',(object-symbol obj)))
  47.   (w 'add 'command :label "Detail"
  48.                 :command `(inspect-menu-Detail ',(object-symbol obj)))
  49.   (if (detailed? obj) ((inspect-m-wid obj) 'disable "Detail"))
  50.   (w 'add 'command :label "View" 
  51.                 :command `(inspect-menu-View ',(object-symbol obj)))
  52.   (if (viewed? obj) ((inspect-m-wid obj) 'disable "View")))
  53.  
  54. (define (inspect-menu-Eval obj)
  55.   (eval-string (format #f "(set! ~a ~a)" obj ((inspect-e-wid obj) 'get))))
  56.  
  57. (define (inspect-menu-Quote obj)
  58.   (eval-string (format #f "(set! ~a '~a)" obj ((inspect-e-wid obj) 'get))))
  59.  
  60. (define (inspect-menu-Uninspect key)
  61.   (uninspect (find-object-infos  key)))
  62.  
  63. (define (inspect-menu-Detail key)
  64.   (let ((obj (find-object-infos  key)))
  65.     (detail obj)
  66.     ((inspect-m-wid obj) 'disable "Detail")
  67.     (if (viewed? obj) ((view-m-wid obj) 'disable "Detail"))))
  68.  
  69. (define (inspect-menu-View key)
  70.   (let ((obj (find-object-infos  key)))
  71.     (view obj)
  72.     ((inspect-m-wid obj) 'disable "View")
  73.     (if (detailed? obj) ((detail-m-wid obj) 'disable "View"))))
  74.  
  75. (define (create-inspector)
  76.   (define w [toplevel INSPECTOR_WIDGET_NAME])
  77.   (wm 'title w "General inspector")
  78.   (wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
  79.   (define menu-w (create-menu-widget (& INSPECTOR_WIDGET_NAME ".menu")))
  80.   (pack menu-w :side "top" :fill "x" :padx 4 :pady 2)
  81.   ((widget menu-w ".help.m") 'add 'command :label "General inspector"
  82.                  :command '(stk:make-help General-Inspector-help))
  83.   (pack [menubutton (& INSPECTOR_WIDGET_NAME ".menu.command") :text "Command"]
  84.     :side "left")
  85.   (define cmd-w (eval [menu (& INSPECTOR_WIDGET_NAME ".menu.command.m")]))
  86.   (cmd-w 'add 'command :label "Uninspect all" :command '(destroy-inspector))
  87.   (cmd-w 'add 'command :label "Undebug" :command '(undebug))
  88.   (tk-set! (widget INSPECTOR_WIDGET_NAME ".menu.command") :menu cmd-w)
  89.   (pack [frame (& INSPECTOR_WIDGET_NAME ".caption")]
  90.     :side "top" :fill "x" :padx 4)
  91.   (pack [label (& INSPECTOR_WIDGET_NAME ".caption.l1")
  92.            :text "Objects" :width 20]
  93.     :side "left")
  94.   (pack [label (& INSPECTOR_WIDGET_NAME ".caption.l2")
  95.            :text "Values" :width 40]
  96.     :side "left" :padx 4)
  97.   (pack [frame (& INSPECTOR_WIDGET_NAME ".f1")]
  98.     :fill "both" :expand "yes" :padx 4 :pady 2))
  99.  
  100.  
  101. (define (destroy-inspector) 
  102.   (for-each uninspect-object inspected-objects-list))
  103.  
  104. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  105. ;;;;
  106. ;;;; inspect
  107. ;;;;
  108. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  109.  
  110. (define (inspect obj)
  111.   (when (= (winfo 'exist INSPECTOR_WIDGET_NAME) 0) (create-inspector))
  112.   ;; Kludge to avoid problems . Should be modified [eg]
  113.   (let ((obj-val (inspect::eval obj)))
  114.     (when (eqv? (inspect::typeof obj-val) 'widget)
  115.       (set! obj obj-val)))
  116.  
  117.   (unless (inspected? obj)
  118.      (inspect-object obj)
  119.      (let ((obj-val (format #f "~S" (inspect::eval obj))))
  120.        (pack [frame (inspect-frame-str obj)] :side "top" :fill "x")
  121.        (pack [menubutton (inspect-mb-str obj)
  122.              :relief "raised" :bd 2 :bitmap BITMAP_MENU]
  123.          :side "right")
  124.        (pack [label (inspect-l-str obj) :relief "groove" :bd 2
  125.             :anchor "w" :text (format #f "~S" obj)
  126.             :width 20 :font MEDIUM_FONT]
  127.          :side "left")
  128.        (pack [entry (inspect-e-str obj) :relief "sunken" :bd 2 :width 40] 
  129.          :fill "x" :expand "yes" :padx 4)
  130.        (create-inspect-menu obj)
  131.        (tk-set! (inspect-mb-wid obj) :menu (inspect-m-wid obj))
  132.        
  133.        (let ((E (inspect-e-wid obj)))
  134.      (E 'insert 0 obj-val)
  135.  
  136.      ;; If obj is a symbol, lets the entry modifiable. Otherwise let it as is
  137.      (if (modifiable-object? obj)
  138.          [begin
  139.            (bind E "<Return>"     `(inspect-menu-Eval ',obj))
  140.            (bind E "<Shift-Return>" `(inspect-menu-Quote ',obj))]
  141.          [inspect::shadow-entry E]))))
  142.  
  143.   ;; Destroy Event -> set the list of inspected object to '()
  144.   (bind  INSPECTOR_WIDGET_NAME "<Destroy>" '(set! inspected-objects-list '()))
  145.  
  146.   ;; Allow resizing only in width
  147.   (update 'idletasks)
  148.   (let ((req-h (winfo 'reqheight INSPECTOR_WIDGET_NAME)))
  149.     (wm 'minsize INSPECTOR_WIDGET_NAME 0 req-h)
  150.     (wm 'maxsize INSPECTOR_WIDGET_NAME SCREEN_WIDTH req-h)
  151.     (wm 'geometry INSPECTOR_WIDGET_NAME 
  152.     (& (winfo 'width INSPECTOR_WIDGET_NAME) "x" req-h))))
  153.  
  154. (define (inspect-object obj)
  155.   (set! inspected-objects-list (cons obj inspected-objects-list))
  156.   (unless (object-infos obj)
  157.       (add-object-infos obj)
  158.       (if (symbol? obj) (trace-var obj `(update-object ',obj)))))
  159.  
  160. (define (inspect-display obj)
  161.   (let ((entry-w (inspect-e-wid obj)))
  162.     (entry-w 'delete 0 'end)
  163.     (entry-w 'insert 0 (->object (eval obj)))))
  164.  
  165. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  166. ;;;;
  167. ;;;; uninspect
  168. ;;;;
  169. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  170.  
  171. (define (uninspect obj)
  172.   (when (inspected? obj) (uninspect-object obj))     
  173.   (update 'idletasks)
  174.   (when (= (winfo 'exist INSPECTOR_WIDGET_NAME) 1)
  175.     (let ((req-h (winfo 'reqheight INSPECTOR_WIDGET_NAME)))
  176.       (wm 'minsize INSPECTOR_WIDGET_NAME 0 req-h)
  177.       (wm 'maxsize INSPECTOR_WIDGET_NAME SCREEN_WIDTH req-h)
  178.       (wm 'geometry INSPECTOR_WIDGET_NAME 
  179.           (& (winfo 'width INSPECTOR_WIDGET_NAME) "x" req-h)))))
  180.  
  181.  
  182. (define (uninspect-object obj)
  183.   (set! inspected-objects-list (list-remove obj inspected-objects-list))
  184.   (destroy (inspect-frame-wid obj))
  185.   (when (null? inspected-objects-list) (destroy INSPECTOR_WIDGET_NAME))
  186.   (if (detailed? obj) ((detail-m-wid obj) 'enable "Inspect"))
  187.   (if (viewed? obj)   ((view-m-wid obj)   'enable "Inspect"))
  188.   (unless (or (detailed? obj) (viewed? obj))
  189.       (remove-object-infos obj)
  190.       (if (symbol? obj) (untrace-var obj))))
  191.